Amiga Format CD 6/Amiga Format AFCD06 (Nov 1996, Issue 90).iso/serious/commercial/cloanto/colortype/rexx/processfont.ctrx

Text File | 1996-06-01 | 5KB | 229 lines

/* ColorType Amiga Rexx script - Copyright © 1996 Cloanto Italia srl */

/* $VER: ProcessFont.ctrx 1.1 */

/**
 This script transforms the current font (which should be a black & white
 font) into a "risen" or "embossed" color font. The script uses
 Personal Paint for image processing, and shows how the two programs
 can interact.

 Each character is passed by ColorType to Personal Paint for processing.
 Depending on the options, either the "Rise High" or "Emboss Low" filters
 are applied, always followed by a "Blur Low".
*/

OPTIONS RESULTS
OPTIONS FAILAT 10000

IF ARG(1, EXISTS) THEN DO
    PARSE ARG CTPORT
    /* started from application: can be stopped with <Shift-Esc> */
    no_progress = 'NOPROGRESS'
END
ELSE DO
    CTPORT = 'COLORTYPE'
    /* started from Workbench: can be stopped using the progress requester "Stop" gadget */
    no_progress = ' '
END

PPPORT = 'PPAINT'

IF ~StartProg('ColorType', 'ColorType:ColorType', CTPORT, 1) THEN
    EXIT 10
IF ~StartProg('Personal Paint', 'PPaint:PPaint', PPPORT, 4) THEN
    EXIT 11

SIGNAL ON Break_C

ADDRESS VALUE PPPORT
LockGUI    /* Lock Personal Paint */

ADDRESS VALUE CTPORT
LockGUI    /* Lock ColorType */

ScreenToFront
Request '"Font Processing" "LIST = _Effect:, 2, 0, 20, 3, Rise, Emboss "'
IF RC = 0 THEN DO
    IF RESULT.1 = 0 THEN DO
        proc_filt = 'Rise High'
        gridpen = 5
        plt_data = '464F524D 00000040 494C424D 424D4844 00000014 00000000 00000000 03020180 00000000 00000000 434D4150 00000018 CACACA92 9292FFFF FFAAAAAA 6D6D6D49 49492424 24000000'X
    END
    ELSE DO
        proc_filt = 'Emboss Low'
        gridpen = 3
        plt_data = '464F524D 00000040 494C424D 424D4844 00000014 00000000 00000000 03020180 00000000 00000000 434D4150 00000018 CACACA00 00002424 24494949 6D6D6D92 9292AAAA AAFFFFFF'X
    END

    GetChar
    scnum = RESULT
    SetChar FIRSTON
    IF RC = 0 THEN DO
        /* not an empty font */
        errcode = 0
        Get 'XMAX'
        xmax = RESULT + 4
        Get 'YMAX'
        ymax = RESULT + 4

        Set 'FORCE "XMAX='xmax'" "YMAX='ymax'" "COLORS=8"'
        IF RC = 0 THEN DO
            /* Create a grayscale palette file */
            tmpfname = 'T:ctrx_plt.'PRAGMA('ID')
            IF OPEN(pltfile, tmpfname, 'W') THEN DO
                WRITECH(pltfile, plt_data)
                CALL CLOSE(pltfile)
            END

            SetPen 'GRID 'gridpen' REMAP -1'

            ADDRESS VALUE PPPORT        /* Set Personal Paint environment */
            DelFrames ALL
            ClearImage
            Set '"IMAGEW='xmax'" "IMAGEH='ymax'" "COLORS=8" "PALETTE=""'tmpfname'""" "SCREENW='xmax'" "SCREENH='ymax'"'
            IF RC = 0 THEN DO
                xmax = xmax - 1
                ymax = ymax - 1
                ADDRESS VALUE CTPORT

                ADDRESS COMMAND 'Delete >NIL: 'tmpfname'#?'
                tmpfname = 'T:ctrx_pic.'PRAGMA('ID')

                DO FOREVER
                    IsBlank
                    IF RESULT = 0 THEN DO
                        GetXSize
                        xsize = RESULT
                        GetSpace
                        space = RESULT
                        GetKern
                        kern = RESULT

                        SaveImage no_progress 'FORCE FILE 'tmpfname' FORMAT ILBM'
                        IF RC = 0 THEN DO

                            ADDRESS VALUE PPPORT        /* Personal Paint processing */

                            LoadBrush 'NOPROGRESS FORCE FILE 'tmpfname
                            IF RC = 0 THEN DO
                                PaintMode REPLACE
                                SetBrushAttr HANDLEX 0 HANDLEY 0
                                xoffs = (xmax + 1 - xsize) % 2        /* allow extra space: the processing can "fatten" the character */
                                PutBrush xoffs 2
                                Process '"'proc_filt'"' 0 0 xmax ymax
                                Process '"Blur Low"' 0 0 xmax ymax
                                GetRectBrush 0 0 xmax ymax
                                ClearImage
                                SaveBrush 'NOPROGRESS FORCE FILE 'tmpfname' FORMAT ILBM'
                                FreeBrush 'FORCE'
                            END

                            ADDRESS VALUE CTPORT        /* back to ColorType */

                            LoadImage no_progress 'FORCE NOSTRETCH FILE 'tmpfname
                            IF RC = 0 THEN DO
                                Chop    /* remove unused extra space */
                                GetXSize
                                new_xsize = RESULT
                                space = space + (new_xsize - xsize)
                                SetSpace space
                                SetKern kern
                            END
                            ELSE DO
                                errcode = RC
                                IF RC = 5 THEN
                                    errmess = 'User abort during load.'
                                ELSE
                                    errmess = 'Error 'RC' during load.'
                                LEAVE
                            END
                        END
                        ELSE DO
                            errcode = RC
                            IF RC = 5 THEN
                                errmess = 'User abort during save.'
                            ELSE
                                errmess = 'Error 'RC' during save.'
                            LEAVE
                        END
                    END
                    SetChar NEXTON
                    IF RC ~= 0 THEN
                        LEAVE
                END
                ADDRESS COMMAND 'Delete >NIL: 'tmpfname'#?'
            END
            ELSE DO
                errcode = RC
                errmess = 'PPaint environment cannot be set:_error 'RC'.'
            END
        END
        ELSE DO
            errcode = RC
            errmess = 'New font format cannot be set:_error 'RC'.'
        END

        IF errcode > 0 THEN DO
            SAY errmess
            RequestNotify 'PROMPT="'errmess'"'
        END
    END
    SetChar scnum
END
UnlockGUI

ADDRESS VALUE PPPORT
UnlockGUI

EXIT 0


StartProg:
    prog_name  = ARG(1)
    prog_fname = ARG(2)
    prog_port  = ARG(3)
    prog_rxver = ARG(4)

    IF ~SHOW('P', prog_port) THEN DO
        IF EXISTS(prog_fname) THEN DO
            ADDRESS COMMAND 'Run >NIL: "'prog_fname'"'
            DO 30 WHILE ~SHOW('P',prog_port)
                 ADDRESS COMMAND 'Wait >NIL: 1 SEC'
            END
        END
        ELSE DO
            SAY prog_name' could not be loaded.'
            RETURN 0
        END
    END

    IF ~SHOW('P', prog_port) THEN DO
        SAY prog_name' Rexx port could not be opened.'
        RETURN 0
    END

    IF prog_rxver > 1 THEN DO
        ADDRESS VALUE prog_port
        Version 'REXX'
        IF RESULT < prog_rxver THEN DO
            errmess = 'This script requires a newer_version of 'prog_name'.'
            SAY errmess
            RequestNotify 'PROMPT="'errmess'"'
            RETURN 0
        END
    END

    RETURN 1


Break_C:

    ADDRESS VALUE CTPORT
    UnlockGUI
    ADDRESS VALUE PPPORT
    UnlockGUI
    SIGNAL OFF Break_C

    RETURN